home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / dblk2.zip / DBLOOK.PAS < prev    next >
Pascal/Delphi Source File  |  1989-09-30  |  17KB  |  485 lines
  1. unit dblook;
  2. { DBLOOK is a Turbo Pascal Unit which reads Dbase III + .DBF files,
  3.   displays the structure information on the screen, converts from
  4.   Dbase format to various internal formats to assist gathering data
  5.   from Dbase data files.
  6.  
  7.   The program was designed to provide simple routines to read dbase
  8.   files to generate reports.
  9.  
  10.   Only one Dbase file may be open at one time (you may change it as
  11.   the source code is provided) and index files are not supported.
  12.  
  13.   Each record will be placed in a character buffer dbbuf[4096] and
  14.   may be used directly or the functions in this package may be used
  15.   to extract data items of interest into more usable Pascal variables.
  16.  
  17.   If you make major improvements to the program, let me know as
  18.   the ongoing effort to improve the performance of Dbase requires
  19.   more tools.
  20.  
  21.   Turbo Pascal 5.5 was used to develope the program.
  22.  
  23. Some functions return STD_ERR_CODES, they are defined as follows:
  24.       -1 = (BOF) Beginning of .DBF file.
  25.        0 = (DBOK) No errors.
  26.        1 = (EOF) End of DBF file.
  27.  
  28.   Gerald Rohr   RR#3    Anamosa, Iowa 52205
  29.   CompuServe [70035,1223]     Genie  g.rohr
  30.  
  31.                          Revision History
  32.   ----------------------------------------------------------------
  33.   Rev 1.0 26 Sep 87 Original Release                           gbr
  34.   Rev 2.0 29 Sep 89 Reworked to longints, records, TP5.5       gbr
  35.  }
  36.  
  37. { ----Globals for your program------ }
  38. interface
  39. const
  40.    BOF       = -1;    { Beginning of .DBF file. }
  41.    DBOK      =  0;    { No errors. }
  42.    EOF       =  1;    { End of DBF file. }
  43.    READ_ERR  =  2;    { Blockread error }
  44.    CLOSE_ERR =  3;    { Error closing .DBF file }
  45.  
  46. type
  47.    rdef = record                  { Dbase record definitions we use }
  48.       name       :string[10];
  49.       rtype      :char;           { type of record - C,N,D,L,etc.         }
  50.       fld_addr   :longint;        { not used }
  51.       width      :byte;           { total field width of this record      }
  52.       decp       :byte;           { number of digits to right of decimal  }
  53.       multi_user :integer;        { reserved for multi user }
  54.       work_id    :byte;           { Work area ID }
  55.       m_user     :integer;        { reserved for multi_user }
  56.       set_fields :byte;           { SET_FIELDS flag }
  57.       resrvd     :array[1..8] of byte;      { 8 bytes reserved }
  58.       stloc      :integer;        { offset from start of field where this }
  59.    end;
  60.  
  61.    db4head = record  { Dbase III + header definition        }
  62.       dbvno        :byte;  { version number (03h or 83h ) }
  63.       updyr        :byte;  { last update YY MM DD         }
  64.       updmo        :byte;
  65.       upddy        :byte;
  66.       no_rec       :longint; { number of record in database }
  67.       header_bytes :integer; { number of bytes in header }
  68.       rec_bytes    :integer; { number of bytes in records }
  69.       tmp          :array[1..20] of char;   { reserved bytes in header }
  70.    end;
  71.  
  72. var
  73.    dbbuf    :array[1..4096] of char;{ Dbase record }
  74.    dbhead   :db4head;               { header of DBF file }
  75.    rstru    :array[1..50] of rdef;  { holds our representation of the database structure }
  76.    no_col   :integer;               { number of columns in database }
  77.  
  78.  
  79. procedure showstruc;
  80.           { displays the information found in the dbase header to the screen, used
  81.             primarily to check if the file definition is correct.
  82.           }
  83. function dbuse(dbfilename:string):integer;
  84.           { reads and stores header information on a Dbase III+ .dbf file.
  85.             Must be the first call in your program as it opens the Dbase
  86.             file name dbfilename.  Returns STD_ERR_CODES.}
  87. function dbclose:integer;
  88.           { Call at end of your application to close the Dbase file.  For now
  89.             there is only one file to close, if extended to use
  90.             multiple database files then this procedure would be required.
  91.             Returns STD_ERR_CODES.
  92.           }
  93.           procedure list_all_recs;
  94.           { list all records in the dbase file starting with record 1, listing is
  95.             in a SDF format.
  96.           }
  97. function version_no:string;
  98.           { Returns the string representation of the version of the
  99.             dblook.pas package.
  100.           }
  101. function dbfldno(fname:string):integer;
  102.           { Returns an integer which is the number in the rstru array where fname
  103.             is located.  Used to enable user to use field names in functions to
  104.             return data.  Returns 0 if fname not found.
  105.           }
  106. function dbstr(fldno:integer):string;
  107.           { Returns the string representation of any field of the database.  This
  108.             string is filled out to the full field length by padding with spaces.
  109.           }
  110. function dbint(fldno:integer):integer;
  111.           { Returns the integer representation of any field of the database.
  112.           }
  113. function dblong(fldno:integer):longint;
  114.           { Returns the long integer representation of any field of the database.
  115.           }
  116. function dbreal(fldno:integer):real;
  117.           { Returns the long integer representation of any field of the database.
  118.           }
  119. function dblogic(fldno:integer):boolean;
  120.           { returns true or false representing the logical value of the field.
  121.           }
  122. function dbdeleted:boolean;
  123.           { Returns true if record in dbbuf[] is marked as deleted, else
  124.             returns false.
  125.           }
  126. function dbgoto(rec_no:longint):integer;
  127.           { Fills the dbbuf[] with data from rec_no record of the database, returns
  128.             STD_ERR_CODES.  dbbuf[] is filled with rec_no or rec 1 for BOF, etc.
  129. function dbrecno:longint;
  130.           { Returns the present record number of the database.
  131.           }
  132. function dbskip(rec_no:longint):integer;
  133.           { positions .DBF file forward (+rec_no) or backwards (-rec_no) rec_no
  134.             records from present position.  Fills dbbuf[] from new DBF record.
  135.             Returns  STD_ERR_CODES.
  136.           }
  137. function dbtop:integer;
  138.           { Positions .DBF file to record 1, fills dbbuf[] with data
  139.           }
  140. function dbbottom:integer;
  141.           { Positions .DBF file to last record, fills dbbuf[] with data
  142.           }
  143.  
  144. { ------- implenentation variables and code follow ------ }
  145. implementation
  146.  
  147. const
  148.    vno  = 'DBLOOK V2.0';            { release version number }
  149.  
  150. type
  151.    db4ref = record
  152.       name       :array[1..11] of char; { Name of this record             }
  153.       rtype      :char;           { type of record - C,N,D,L,etc.         }
  154.       fld_addr   :longint;        { not used }
  155.       width      :byte;           { total field width of this record      }
  156.       decp       :byte;           { number of digits to right of decimal  }
  157.       multi_user :integer;        { reserved for multi user }
  158.       work_id    :byte;           { Work area ID }
  159.       m_user     :integer;        { reserved for multi_user }
  160.       set_fields :byte;           { SET_FIELDS flag }
  161.       resrvd     :array[1..8] of byte;      { 8 bytes reserved }
  162.    end;                           { record starts                         }
  163.  
  164. var
  165.    dbfin     :file;
  166.    i,j,k     :integer;
  167.    rec_stru  :db4ref;               { actual database record structure }
  168.    numread   :word;
  169.    infile    :string;               { name of database }
  170.    db_rec_no :longint;              { Present record of DBF file }
  171.  
  172. procedure showstruc;
  173. { displays the information found in the dbase header to the screen, used
  174.   primarily to check if the file definition is correct.
  175. }
  176. var
  177.    i :integer;
  178.    tmp :string[20];
  179.    tpe :string[10];
  180.  
  181. begin
  182.    writeln('Structure for database :',infile);
  183.    with dbhead do
  184.    begin
  185.    writeln('Date of last update    :',updmo:2,'/',upddy:2,'/',updyr:2);
  186.    writeln('Number of records      :',no_rec:8);
  187.    writeln('Column     Type       Width  Decimals Offset');
  188.    writeln('---------- ---------- ------ -------- ------');
  189.    writeln('           Delete Flg      1               1');
  190.    end;
  191.    for i := 1 to no_col do
  192.       begin
  193.       with rstru[i] do
  194.          begin
  195.          tmp := copy(concat(rstru[i].name,'          '),1,10);
  196.          case rtype of
  197.             'C' :tpe := 'Character';
  198.             'N' :tpe := 'Numeric  ';
  199.             'D' :tpe := 'Date     ';
  200.             'L' :tpe := 'Logical  ';
  201.             'M' :tpe := 'Memo     ';
  202.             else tpe := 'Unknown  ';
  203.          end;
  204.          writeln(tmp,' ',tpe,'    ',width:4,'      ',decp:3,'   ',rstru[i].stloc:4);
  205.  
  206.       end;  {with}
  207.    end;  {for}
  208.    writeln;
  209.    writeln('                       Record length -> ',dbhead.rec_bytes:4);
  210. end; {procedure showstruc }
  211.  
  212. procedure calc_coloff;
  213. { calculate the offset from the beginning of the record for each
  214.   data element.}
  215. var
  216.    i,j :integer;
  217. begin
  218.    j := 2;       { first element of record is deleted flag }
  219.    for i := 1 to no_col do
  220.       begin
  221.       with rstru[i] do
  222.          begin
  223.          stloc := j;
  224.          j := j + width;
  225.       end; {with}
  226.    end;  {for}
  227. end;   {procedure calc_coloff}
  228.  
  229. function dbgoto(rec_no:longint):integer;
  230. { Fills the dbbuf[] with data from rec_no record of the database, returns
  231.   STD_ERR_CODES.
  232. }
  233. var
  234.    numread    :word;
  235.    fileloc    :longint;
  236. begin
  237.    dbgoto := DBOK;    { default to success }
  238.    if(rec_no < 1) then
  239.       begin
  240.       dbgoto := BOF;
  241.       rec_no := 1;
  242.    end;
  243.    if(rec_no > dbhead.no_rec) then
  244.       begin
  245.       dbgoto := dbhead.no_rec;
  246.       rec_no := dbhead.no_rec;
  247.    end;
  248.    db_rec_no := rec_no;
  249.    fileloc := (dbhead.header_bytes + ((rec_no -1) * dbhead.rec_bytes));
  250.    seek(dbfin,fileloc);
  251.    blockread(dbfin,dbbuf,dbhead.rec_bytes,numread);
  252.    if(numread = 0) then
  253.       dbgoto := READ_ERR;
  254. end; {function dbgoto}
  255.  
  256. function dbuse(dbfilename:string):integer;
  257. { reads and stores header information on a Dbase III+ .dbf file.
  258.   Must be the first call in your program as it opens the Dbase database
  259.   file name dbfilename.
  260.   Returns STD_ERR_CODES, reads record 1 into dbbuf[].
  261. }
  262. var
  263.    numread :word;
  264.    i,j     :integer;
  265. begin
  266.    dbuse := DBOK;        { default to successfull }
  267.    infile := dbfilename;      { save filename }
  268.    assign(dbfin,dbfilename);
  269.    reset(dbfin,1);            { record size to read = 1 }
  270.    blockread(dbfin,dbhead,sizeof(dbhead),numread);
  271.    if(numread = 0) then
  272.       dbuse := READ_ERR
  273.    else
  274.       begin
  275.       { calc the number of columns of data to read, put in global variable }
  276.       no_col := ((dbhead.header_bytes - sizeof(dbhead)) div 32);
  277.       for i := 1 to no_col do       { read the column definitions }
  278.          begin
  279.          blockread(dbfin,rec_stru,sizeof(rec_stru),numread);
  280.          if(numread = 0) then
  281.             dbuse := READ_ERR
  282.          else
  283.             begin                   { move it to users structure }
  284.             rstru[i].rtype := rec_stru.rtype;
  285.             rstru[i].fld_addr := rec_stru.fld_addr;
  286.             rstru[i].width := rec_stru.width;
  287.             rstru[i].decp := rec_stru.decp;
  288.             rstru[i].multi_user := rec_stru.multi_user;
  289.             rstru[i].work_id := rec_stru.work_id;
  290.             rstru[i].m_user := rec_stru.m_user;
  291.             rstru[i].set_fields := rec_stru.set_fields;
  292.             for j := 1 to 8 do
  293.                rstru[i].resrvd[j] := rec_stru.resrvd[j];
  294.             j := 1;                 { convert from C string to Pascal string }
  295.             while((ord(rec_stru.name[j]) > 0) and (j <= 10)) do
  296.                begin
  297.                rstru[i].name[j] := rec_stru.name[j];
  298.                inc(j);
  299.             end;
  300.             rstru[i].name[0] := chr(lo(j-1));    { set string length }
  301.          end;
  302.       end;
  303.       calc_coloff;                        { calculate column offsets }
  304.       dbuse := dbgoto(1);
  305.    end;
  306. end;   {function dbuse}
  307.  
  308. function dbclose:integer;
  309. { Call at end of your application to close the Dbase file.  For now
  310.   there is only one file to close, if extended to use
  311.   multiple database files then this procedure would be required.
  312.   Returns STD_ERR_CODES.
  313. }
  314. begin
  315.    dbclose := DBOK;
  316.    close(dbfin);
  317. end; {procedure dbclose}
  318.  
  319. procedure list_all_recs;
  320. { list all records in the dbase file starting with record 1, listing is
  321.   in a SDF format.
  322. }
  323. var
  324.    tmp_recno  :longint;
  325.    numread    :word;
  326.    j          :integer;
  327. begin
  328.    seek(dbfin,dbhead.header_bytes); { positionto first record }
  329.    { file is already open and positioned to the first data record }
  330.    tmp_recno := dbhead.no_rec;
  331.    while (tmp_recno > 0) do  { need a while loop for more than int }
  332.       begin
  333.       blockread(dbfin,dbbuf,dbhead.rec_bytes,numread);
  334.       if(numread > 0) then
  335.          begin
  336.          write('!');
  337.          for j := 1 to dbhead.rec_bytes do
  338.             write(dbbuf[j]);
  339.          writeln('!');
  340.          dec(tmp_recno);
  341.       end
  342.       else
  343.          writeln('Error reading record..');
  344.    end;
  345. end; {procedure list_all_recs}
  346.  
  347. function version_no:string;
  348. { Returns the string representation of the version of the
  349.   dblook.pas package.
  350. }
  351. begin
  352.    version_no := vno;
  353. end; {function version_no}
  354.  
  355. function dbfldno(fname:string):integer;
  356. { Returns an integer which is the number in the rstru array where fname
  357.   is located.  Used to enable user to use field names in functions to
  358.   return data.  Returns 0 if fname not found.
  359. }
  360. var
  361.    i   :integer;
  362. begin
  363.    dbfldno := 0;       { default to not found }
  364.    for i := 1 to no_col do
  365.       if(fname = rstru[i].name) then
  366.          dbfldno := i;
  367. end; {function dbfldno}
  368.  
  369. function dbstr(fldno:integer):string;
  370. { Returns the string representation of any field of the database.  This
  371.   string is filled out to the full field length by padding with spaces.
  372. }
  373. var
  374.    tmp  :string;
  375.    i    :integer;
  376. begin
  377.    for i := 1 to rstru[fldno].width do
  378.       tmp[i] := dbbuf[rstru[fldno].stloc + i - 1];
  379.    tmp[0] := chr(rstru[fldno].width);
  380.    dbstr := tmp;
  381. end; {function dbstr}
  382.  
  383. function dbint(fldno:integer):integer;
  384. { Returns the integer representation of any field of the database.
  385. }
  386. var
  387.    tmp      :string;
  388.    i,result :integer;
  389. begin
  390.    for i := 1 to rstru[fldno].width do
  391.       tmp[i] := dbbuf[rstru[fldno].stloc + i - 1];
  392.    tmp[0] := chr(rstru[fldno].width);
  393.    val(tmp,i,result);
  394.    dbint := i;
  395. end; {function dbint}
  396.  
  397. function dblong(fldno:integer):longint;
  398. { Returns the long integer representation of any field of the database.
  399. }
  400. var
  401.    tmp      :string;
  402.    i,result :integer;
  403.    retval   :longint;
  404. begin
  405.    for i := 1 to rstru[fldno].width do
  406.       tmp[i] := dbbuf[rstru[fldno].stloc + i - 1];
  407.    tmp[0] := chr(rstru[fldno].width);
  408.    val(tmp,retval,result);
  409.    dblong := retval;
  410. end; {function dblong}
  411.  
  412. function dbreal(fldno:integer):real;
  413. { Returns the long integer representation of any field of the database.
  414. }
  415. var
  416.    tmp      :string;
  417.    i,result :integer;
  418.    retval   :real;
  419. begin
  420.    for i := 1 to rstru[fldno].width do
  421.       tmp[i] := dbbuf[rstru[fldno].stloc + i - 1];
  422.    tmp[0] := chr(rstru[fldno].width);
  423.    val(tmp,retval,result);
  424.    dbreal := retval;
  425. end; {function dbreal}
  426.  
  427. function dblogic(fldno:integer):boolean;
  428. { returns true or false representing the logical value of the field.
  429. }
  430. var
  431.    i  :integer;
  432. begin
  433.    i := rstru[fldno].stloc;
  434.    if((dbbuf[i] = 'T') or (dbbuf[i] = 't') or (dbbuf[i] = 'Y') or
  435.       (dbbuf[i] = 'y')) then
  436.       dblogic := true
  437.    else
  438.       dblogic := false;
  439. end; {function dblogic}
  440.  
  441. function dbdeleted:boolean;
  442. { Returns true if record in dbbuf[] is marked as deleted, else
  443.   returns false.
  444. }
  445. begin
  446.    if(dbbuf[1] = '*') then
  447.       dbdeleted := true
  448.    else
  449.       dbdeleted := false;
  450. end;  {function dbdeleted}
  451.  
  452. function dbrecno:longint;
  453. { Returns the present record number in the database. }
  454. begin
  455.    dbrecno := db_rec_no;
  456. end;  {function dbrecno}
  457.  
  458. function dbskip(rec_no:longint):integer;
  459.           { positions .DBF file forward (+rec_no) or backwards (-rec_no) rec_no
  460.             records from present position.  Fills dbbuf[] from new DBF record.
  461.             Returns  STD_ERR_CODES.
  462.           }
  463. begin
  464.    if(rec_no > 0) then inc(db_rec_no,rec_no);
  465.    if(rec_no < 0) then dec(db_rec_no,rec_no);
  466.    dbskip := dbgoto(db_rec_no);
  467. end; {function dbskip}
  468.  
  469. function dbtop:integer;
  470.           { Positions .DBF file to record 1, fills dbbuf[] with data }
  471. begin
  472.    dbtop := dbgoto(1);
  473. end; {function dbtop}
  474.  
  475. function dbbottom:integer;
  476.           { Positions .DBF file to last record, fills dbbuf[] with data }
  477. begin
  478.    dbbottom := dbgoto(dbhead.no_rec);
  479. end; {function dbbottom}
  480.  
  481. { ---- end of implementation ---- }
  482.  
  483. begin     { --- initialization --- }
  484. end.  { dblook.pas }
  485.